home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-generator.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  32.7 KB  |  1,010 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-generator.lisp
  3. ; Description:  Generate Domain and Print-Functions for the grammar
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      25-Feb-92
  6. ; Modified:     Thu Jul 28 10:32:44 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1992, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. (IN-PACKAGE  "ZEBU")
  18.  
  19. (declaim (special
  20.           *identifier-continue-chars*
  21.           *identifier-start-chars*
  22.           *domain-structs*
  23.           *domain-types*
  24.           *grammar-options*
  25.           *lex-cats*
  26.           ))
  27.  
  28. ;----------------------------------------------------------------------------;
  29. ; generate-domain-file
  30. ;---------------------
  31. ; Generate the DEFSTRUCT calls to define the domain & dump to FILE
  32. ; When using the meta-grammar, printers will be compiled too.
  33.  
  34. ; file is open when generate-domain-file is called.
  35. ; return true if anything was written.
  36.  
  37. ; If DEFSTRUCT is used in the grammar file  -- *domain-structs*  is not
  38. ; () -- the domain does not need to be generated.
  39.  
  40. (defun generate-domain-file (file port &aux domain printers)
  41.   (unless *domain-structs*
  42.     (when (setq domain
  43.         (prepare-domain
  44.          (or (get-grammar-options-key ':DOMAIN)
  45.              ;; set the domain keyword, s.t. at load time
  46.              ;; the domain definition is present
  47.              (let ((d (process-domain-definition)))
  48.                (when d
  49.              (nconc *grammar-options*
  50.                 (list ':DOMAIN d)))
  51.                d))))        ; sets *domain-type-hierarchy*
  52.       (when (string= (grammar-name *compiler-grammar*)
  53.              "zebu-mg")
  54.     (format t "~%Generating Print-functions ..")
  55.     (setq printers (gen-printers)))))
  56.   (format t "~%Writing domain to ~a~%" file)
  57.   ;; Dump out hierarchy
  58.   (let* ((structs (or (reverse *domain-structs*)
  59.               (generate-domain domain printers)))
  60.      (CL-pkg  #-LUCID (find-package "COMMON-LISP")
  61.           #+LUCID (find-package "LUCID-COMMON-LISP"))
  62.      (Lisp-pkgs
  63.       (cons CL-pkg (package-use-list CL-pkg))))
  64.     (dolist (f structs)
  65.       (let ((struct-name (defstruct-name f)))
  66.     (when (member (symbol-package struct-name)
  67.               Lisp-pkgs)
  68.       (warn "~s was chosen as the name of domain type, ~%but the symbol is already defined in the ~s"
  69.         struct-name (symbol-package struct-name)))        
  70.     (pprint f port)
  71.     (terpri port)
  72.     ;; build the kb-hierarchy even if defstructs are used
  73.     (when *domain-structs*
  74.       (format port "(ZB::DEF-KB-DOMAIN-TYPE '~s '~s '~s)~%"
  75.           struct-name
  76.           (defstruct-super f)
  77.           (defstruct-slots f)))
  78.     ))
  79.     structs))
  80.  
  81. (defun defstruct-name (x)
  82.   (let ((n (cadr x)))
  83.     (if (listp n) (car n) n)))
  84.  
  85. (defun defstruct-super (x)
  86.   (let ((n (cadr x)))
  87.     (when (listp n)
  88.       (let ((include (assoc ':include (cdr n))))
  89.     (when include (second include))))))
  90.  
  91. (defun defstruct-slots (x)
  92.   (mapcar #'(lambda (sd) (if (listp sd) (car sd) sd))
  93.       (cddr x)))
  94.  
  95. ;----------------------------------------------------------------------------;
  96. ; generate-domain
  97. ;----------------
  98. ; Given domain D and an alist PRINTERS with pairs (<type> . <print-function>)
  99. ; return a list of DEFSTRUCT calls
  100.  
  101. (defun generate-domain (d printers &aux code)
  102.   (flet ((parse-slots (l)
  103.        (mapcar #'(lambda (s)
  104.                (if (atom s)
  105.                s
  106.              `(,(car s) nil :type (or null ,(cadr s)))))
  107.            l)))
  108.     (flet ((slots (x)
  109.          (do ((xrest x (cddr xrest)))
  110.          ((null xrest) nil)
  111.            (if (eq (car xrest) ':slots)
  112.            (return (parse-slots (cadr xrest))))))
  113.        (make-struct (name include slots constructor?)
  114.          `(defstruct (,name
  115.               (:include ,include)
  116.               ,@(let ((fn (assoc name printers)))
  117.                   (when fn
  118.                 `((:print-function ,(cdr fn)))))
  119.               ,@(unless constructor?
  120.                   (list '(:constructor nil)))
  121.               )
  122.            ,@slots)))
  123.       (labels ((generate-domain-aux (sub super args constructor?)
  124.          (unless (eq sub super)
  125.            (push (make-struct sub super (slots args) constructor?)
  126.              code))
  127.          (do ((xrest args (cddr xrest))) ((null xrest))
  128.            (when (eq (car xrest) ':subtype)
  129.              (let ((newsub (cadr xrest)))
  130.                (if (atom newsub)
  131.                (push (make-struct newsub sub nil t) code)
  132.              (generate-domain-aux
  133.               (car newsub) sub (cdr newsub) t)))))))
  134.     (when d
  135.       (generate-domain-aux (car d) 'kb-domain (rest d) nil)
  136.       (nreverse code))))))
  137.  
  138.  
  139. ;----------------------------------------------------------------------------;
  140. ; process-domain-definition
  141. ;--------------------------
  142. ; Transform the list of DOMAIN-TYPEs into the hierarchical structure
  143. ; with root KB-DOMAIN, and :SUBTYPE, :SLOTS arcs
  144. (defun process-domain-definition (&aux (R (list 'KB-domain)))
  145.   (labels ((find-super (node supertype)
  146.          ;; node is the list form of the domain def
  147.          (if (null node)
  148.          'Nil
  149.            (if (eq (car node) supertype)
  150.            node
  151.          (do ((n (cdr node) (cddr n)))
  152.              ((null n) nil)
  153.            (when (eq (car n) ':subtype)
  154.              (let ((r (find-super (cadr n) supertype)))
  155.                (when r (return r)))))))))
  156.     (when (null *domain-types*)
  157.       (return-from process-domain-definition nil))
  158.     ;; if there is a supertype in *domain-types* that is 
  159.     ;; undefined, define it as a subtype of KB-domain
  160.     (dolist (node *domain-types*)
  161.       (let ((supertype (domain-type--supertype node)))
  162.     (unless (or (eq supertype 'KB-domain)
  163.             (find supertype *domain-types*
  164.               :key #'domain-type--type))
  165.       (push (make-domain-type
  166.          :-supertype 'KB-domain
  167.          :-type supertype)
  168.         *domain-types*))))
  169.     ;; transform the sorted list to the external :DOMAIN notation
  170.     (let ((domain-types (copy-list *domain-types*)))
  171.       (loop (or domain-types (return R))
  172.         (do ((nodes domain-types (cdr nodes)))
  173.         ((null nodes))
  174.           (let* ((node (first nodes))
  175.              (supertype (domain-type--supertype node))
  176.              (type (domain-type--type node))
  177.              (slots (domain-type--slots node))
  178.              (super (find-super R supertype)))
  179.         (when super
  180.           (nconc super `(:subtype
  181.                  (,type
  182.                   ,@(if slots `(:slots ,slots)))))
  183.           (setq domain-types (delete node domain-types)))))))
  184.     ;; (pprint R)
  185.     R))
  186.  
  187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  188. ;;                        Generate the print-functions
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190. ;----------------------------------------------------------------------------;
  191. ; Non-terminal-p
  192. ;---------------
  193. ; 
  194. (defun Non-terminal-p (constituent)
  195.   (and (symbolp constituent) (not (assoc constituent *lex-cats*))))
  196.  
  197. ;----------------------------------------------------------------------------;
  198. ; 1-constituent-production-p
  199. ;---------------------------
  200. ; 
  201. ; 
  202. (defun 1-constituent-production-p (syntax)
  203.   (= 1 (count-if #'Non-terminal-p syntax))
  204.   )
  205.  
  206. (defun first-nt-constituent (syntax)
  207.   (find-if #'Non-terminal-p syntax)
  208.   )
  209.  
  210. ;; collect for each type the lhs and production-rhs in the alist
  211. ;; type-prod-AL ( (<type> . %1=( %2=(<lhs> . <production-rhs>) .. )) ..)
  212. ;; type-print-fn-AL ( (<type> . (lambda ..)) ..)
  213. ;; Return type-print-fn-AL
  214.  
  215. (defun gen-printers (&aux type-prod-AL type-print-fn-AL user-def-types
  216.               KB-sequence-print-fn-AL KB-sequence-prods
  217.               (print-fn-argl (mapcar #'intern 
  218.                          '("ITEM" "STREAM" "LEVEL"))))
  219.   (flet ((memo (type val)
  220.        (let ((bdg  (assoc type type-prod-AL)))
  221.          (if (null bdg)
  222.          (push (cons type (list val)) type-prod-AL)
  223.            (push val (cdr bdg))))))       
  224.     (maphash #'(lambda (key val) (declare (ignore val))
  225.                (unless (or (member key '(:TOP KB-DOMAIN KB-SEQUENCE))
  226.                    (member (symbol-name key)
  227.                        *open-categories*
  228.                        :test #'string=)
  229.                    (assoc key *lex-cats*))
  230.              (push key user-def-types)))
  231.          *domain-ht*)
  232.     ;; for each type, gather a set of productions that produce it
  233.     ;; also check that the type and its slots are defined
  234.     (dolist (zb-rule *zb-rules*)
  235.       (let ((lhs (car zb-rule)))
  236.     (dolist (prod (zb-rule--productions (cdr zb-rule)))
  237.       (let ((semantics (production-rhs--semantics prod)))
  238.         (if (null semantics)
  239.         (let ((syntax (production-rhs--syntax prod)))
  240.           (when (1-constituent-production-p syntax)
  241.             (let ((nt (first-nt-constituent syntax)))
  242.               (when (eq (car (infer-type-disj-of-expr nt))
  243.                 'kb-sequence)
  244.             (memo 'kb-sequence (cons lhs nt))))))          
  245.           (when (and semantics (feat-term-p semantics))
  246.         (let* ((type (feat-term--type semantics))
  247.                (type-node (gethash type *domain-HT*))
  248.                (slots (feat-term--slots semantics)))
  249.           ;; warn about inconsistent use of the types    
  250.           (if (null type-node)
  251.               (warn "Type: ~S is not defined in this domain" type)
  252.             (dolist (slot slots)
  253.               (let ((slot-label (label-value-pair--label slot))
  254.                 (slot-value (label-value-pair--value slot)))
  255.             (if (KB-legal-slot-p type slot-label)
  256.                 (let ((slot-type (KB-slot-type
  257.                           type slot-label)))
  258.                   (unless (eq slot-type ':TOP)
  259.                 (unless (every
  260.                      #'(lambda (sub)
  261.                          (is-subtype-of sub slot-type))
  262.                      (infer-type-disj-of-expr slot-value))
  263.                   (warn "~S type restriction of ~S violated by ~S"
  264.                     slot-type slot-label slot-value)
  265.                   ;;(break "~%> ~S" prod)
  266.                   )))
  267.               (warn "Slot: ~S is not defined for ~S"
  268.                 slot-label type)))))
  269.           (memo type (cons lhs prod))
  270.           (for-each-supertype
  271.            #'(lambda (node)
  272.                (setq user-def-types
  273.                  (delete (type-tree-node--label node)
  274.                      user-def-types)))
  275.            type)))))))))
  276.   (when user-def-types
  277.     (warn "Types:~{ ~S~}~% were defined but not used." user-def-types))
  278.  
  279.   ;; generate print-function for nonterminals which produce a kb-sequence
  280.   (when (setf KB-sequence-prods (assoc 'KB-sequence type-prod-AL))
  281.     (setf type-prod-AL (delete KB-sequence-prods type-prod-AL)
  282.       KB-sequence-print-fn-AL
  283.       (gen-KB-sequence-printers (cdr KB-sequence-prods))))
  284.   ;; (break "KB-sequence-print-fn-AL ~%~S:" KB-sequence-print-fn-AL)
  285.   ;; now generate the print-function for each type
  286.   ;; unless one has been predefined (via the << foo >> Syntax)
  287.   (dolist (e type-prod-AL type-print-fn-AL)
  288.     (let* ((type (car e))
  289.        (domain-type (find type *domain-types*
  290.                   :key #'domain-type--type))
  291.        (fun (when domain-type
  292.           (domain-type-print-function domain-type))))
  293.       ;; (break "domain-type: ~s" domain-type)
  294.       (when (and domain-type (not fun))
  295.     (let ((%1   (cdr e))        ; ((<lhs> . <prod-rhs>)..)
  296.           clauses good-bdgs unused-bdgs)
  297.       (dolist (%2 %1)        ; (<lhs> . <prod-rhs>)
  298.         (push (gen-print-case %2) clauses))
  299.       ;; <clause> = (short-lambda-list syntax binding-list)
  300.       (multiple-value-bind (cond-clauses bindings)
  301.           (gen-clauses clauses KB-sequence-print-fn-AL)
  302.         ;; split bindings in good ones and unused ones
  303.         (dolist (b bindings)
  304.           (if (null (cdr b))
  305.           (pushnew b unused-bdgs)
  306.         (pushnew b good-bdgs)))
  307.         (setf fun `(lambda (,@print-fn-argl 
  308.                 ,@(when good-bdgs `(&aux .,good-bdgs)))
  309.               (declare (ignore 
  310.                   ,@unused-bdgs
  311.                   .,(if (not good-bdgs)
  312.                     print-fn-argl
  313.                       (cddr print-fn-argl))))
  314.             ,(if (cdr cond-clauses)
  315.                  (progn
  316.                    ;; last cond-clause has antecedent T
  317.                    (setf (caar (last cond-clauses)) t)
  318.                    `(cond ,@(simplify-cond-clauses cond-clauses)))
  319.                ;; the condition must be true
  320.                (cadar cond-clauses)))))))
  321.       (push (cons type fun) type-print-fn-AL))))
  322.  
  323. ;;------------------------------------------------------------------------;;
  324. ;; gen-KB-sequence-printers
  325. ;;-------------------------
  326. ;; generate in-line format forms for KB-sequence first:
  327. ;; KB-sequence-print-fn-AL: ((Constituent . <form(lhs)>)..); 
  328.  
  329. (defun gen-KB-sequence-printers (prods &aux Alist separator)
  330.   (dolist (prod prods Alist)
  331.     ;; prod = (<lhs> . <prod-rhs>)  |  (<lhs> . <symbol>)
  332.     (let ((lhs (car prod)) (rhs (cdr prod)))
  333.       ;; (format t "~%~%Prod: ~s ::= ~s" lhs (if (symbolp rhs) rhs (production-rhs--syntax rhs)))
  334.       (setq separator (decode-separator (if (symbolp rhs) rhs lhs))
  335.         Alist (add-print-fn
  336.            lhs
  337.            (if separator
  338.                `(let ((*kb-sequence-separator* ,separator))
  339.              (declare (special *kb-sequence-separator*))
  340.              (KB-SEQUENCE-print ,lhs nil nil))
  341.              `(KB-SEQUENCE-print ,lhs nil nil))
  342.            Alist))
  343.       ;; (format t "~%Separator: ~s" separator)
  344.       )))
  345.  
  346. (defun decode-separator (name)
  347.   ;; return NIL for the default separator
  348.   (let* ((s (symbol-name name))
  349.      (s-length (length s))
  350.      (last-char-pos (1- s-length)))
  351.     (when (char= (schar s last-char-pos) #\$)
  352.       (let ((sep-ln-char (schar s (1- last-char-pos))))
  353.     (when (digit-char-p sep-ln-char)
  354.       (let ((sep-length (- (char-int sep-ln-char) (char-int #\0))))
  355.         (subseq s 
  356.             (- s-length sep-length 2)
  357.             (- last-char-pos 1))))))))
  358.  
  359. ; (defun get-KB-sequence-fillers (seq &aux R)
  360. ;   (dolist (slot (feat-term--slots seq))
  361. ;     (let ((val (LABEL-VALUE-PAIR--VALUE slot)))
  362. ;       (setq r (if (typep val 'feat-term)
  363. ;           (nconc (get-KB-sequence-fillers val) R)
  364. ;         (cons val R)))))
  365. ;   R)
  366.  
  367. ;----------------------------------------------------------------------------;
  368. ; add-print-fn
  369. ;-------------
  370. ; add the print-function FN for the non-terminal CONSTITUENT to ALIST
  371. ; 
  372. (defun add-print-fn (CONSTITUENT FN ALIST)
  373.   (let ((bdg (assoc CONSTITUENT ALIST)))
  374.     (if (null bdg)
  375.     (acons CONSTITUENT FN ALIST)
  376.       (progn (setf (cdr bdg)
  377.            `(if (null ,CONSTITUENT)
  378.              ""
  379.              ,(if (equal FN "")
  380.               (cdr bdg)
  381.             FN)))
  382.          ALIST))))
  383.  
  384. ;----------------------------------------------------------------------------;
  385. ; clause
  386. ;-------
  387. ; <lambda-list syntax binding-list semantics>
  388. ; 
  389. (defstruct (clause)
  390.   ll syntax bl semantics
  391.   )
  392.  
  393. ;----------------------------------------------------------------------------;
  394. ; gen-print-case
  395. ;---------------
  396. ; given: (<lhs> . <prod-rhs>)
  397. ; return: lambda-list of constituents in lhs
  398. ;         syntax of rhs
  399. ;         for each var in the lambda-list a path of accessors
  400.  
  401. (defun gen-print-case (lhs-rhs-pair)
  402.   (let* ((prod (cdr lhs-rhs-pair))
  403.      (syntax (production-rhs--syntax prod))
  404.      (semantics (production-rhs--semantics prod))
  405.      (ll (mapcan #'(lambda (constituent)
  406.              (unless (stringp constituent) (list constituent)))
  407.              syntax))
  408.      (binding-list
  409.       (mapcar
  410.        #'(lambda (var)
  411.            (let ((p (find-path var semantics)))
  412.          (if (null p)
  413.              (progn
  414.                (warn "~:[Lexical Category~; Non-Terminal~] ~S not used in semantics ~% of ~S."
  415.                  (Non-terminal-p var) var (car lhs-rhs-pair))
  416.                (list var)
  417.                )
  418.            (cons var p))))
  419.           ll)))
  420.     (make-clause
  421.      :ll ll :syntax syntax :bl binding-list :semantics semantics)))
  422.  
  423. ;----------------------------------------------------------------------------;
  424. ; gen-clauses
  425. ;------------
  426. ; Given clauses of the form:
  427. ;  <clause> = <short-lambda-list syntax binding-list semantics>
  428. ; where binding-list = ((<non-terminal-symbol> . <path to access from ITEM>) ..)
  429. ; return: (1) ((<test for print-case> <format stmt derived from syntax>) ..)
  430. ;         (2) a lambda-list binding the %u .. variables used to accessors
  431. ;             derived from the paths.
  432. (defconstant *vars-to-use* '("%R" "%S" "%T" "%U" "%V" "%W" "%X" "%Y" "%Z"))
  433.  
  434. (defun gen-clauses (clauses KB-sequence-print-fn-AL
  435.                 &aux (vars-to-use (mapcar #'intern *vars-to-use*))
  436.                 ;; a set of sets with the same print syntax
  437.                 (partitioning (partition-set #'same-print-syntax clauses))
  438.                 alist cond-clauses)
  439.   (labels ((memo-path (path)
  440.          (let ((bdg (assoc path alist :test #'equal)))
  441.            (if bdg
  442.            (cdr bdg)
  443.          (let ((R (pop vars-to-use)))
  444.            (push (cons path R) alist)
  445.            R))))
  446.        (make-format (syntax bdgs)
  447.          (when syntax
  448.            (let ((R `(format ,(intern "STREAM")
  449.               ,(apply #'concatenate 'string
  450.                   (make-format-string-list syntax))
  451.               ,@(mapcan
  452.                  #'(lambda (const) 
  453.                  (unless (stringp const) 
  454.                    (let ((seq-fn-bdg
  455.                       (assoc
  456.                        const
  457.                        KB-sequence-print-fn-AL))
  458.                      (var (let ((bdg (cdr (assoc const bdgs))))
  459.                         (when bdg (memo-path bdg)))))
  460.                      (list
  461.                       (if seq-fn-bdg
  462.                       `(let ((,const ,var))
  463.                         ,(cdr seq-fn-bdg))
  464.                     (or var
  465.                         (warn "Can't unparse ~s~%~s is unbound in semantics"
  466.                           syntax const)))))))
  467.                  syntax))))
  468.          ;; (format t "~%format: ~s ~a -->~% " syntax bdgs) (pprint R) (break "gen-clauses")
  469.          R))))
  470.     (dolist (eq-print-set partitioning)
  471.       (let (ante (proto  (first eq-print-set)))
  472.     (dolist (eq-print eq-print-set)
  473.       (let ((ll     (clause-ll eq-print))
  474.         (bdgs   (clause-bl eq-print)))
  475.         (pushnew
  476.          (if (null ll)
  477.          (progn 
  478.            ;; (break  "sem: ~s" (clause-semantics eq-print))
  479.            `(equal ,(intern "ITEM") ,(cons-avm
  480.                           (clause-semantics eq-print))))
  481.            (let* (type-list        ; type-preds that have to hold
  482.               (ll-map        ; ((<lvar> . <%var>) ..)
  483.                (mapcar #'(lambda (var)
  484.                    (push (infer-type-predicate var)
  485.                      type-list)
  486.                    (cons var
  487.                      (memo-path
  488.                       (cdr (assoc var bdgs)))))
  489.                    ll))
  490.               (conjuncts
  491.                (mapcan #'(lambda (lvar type)
  492.                    (if (consp type)
  493.                        `((typep ,(cdr lvar) ',type))
  494.                      (if (eq type 'T)
  495.                      ;; delete the variables for which
  496.                      ;; we could not infer a type
  497.                      ()
  498.                        `((,type ,(cdr lvar))))))
  499.                    ll-map (nreverse type-list))))
  500.          (if (cdr conjuncts)
  501.              `(AND . ,conjuncts)
  502.            (car conjuncts))))
  503.          ante :test #'equal)))
  504.     (setq ante (if (cdr ante) (cons 'OR ante) (car ante)))
  505.     (setq cond-clauses
  506.           (insert-clause `(,ante
  507.                    ,(make-format (clause-syntax proto)
  508.                          (clause-bl proto)))
  509.                  cond-clauses))))
  510.     (values cond-clauses
  511.         (mapcar #'(lambda (pair)    ; (<path> .  <%var>)
  512.             (list (cdr pair)
  513.                   (path-to-form (car pair) (intern "ITEM"))))
  514.             alist))))
  515.  
  516. (defun path-to-form (path target)
  517.   (reduce #'(lambda (a b) (list b a))
  518.       path
  519.       :initial-value target))
  520. ;----------------------------------------------------------------------------;
  521. ; insert-clause
  522. ;--------------
  523. ; insert stronger clause at front
  524. ; 
  525. (defun insert-clause (clause clauses)
  526.   (flet ((conjunction? (x) (and (consp x) (eq (car x) 'AND)))
  527.      (conjuncts (x) (rest x))
  528.      (typed-var? (x) (and (consp x) (eq (car x) 'TYPEP)))
  529.      (typed-var-nm (x) (cadr x))
  530.      (typed-var-type (x) (cadr (caddr x)))
  531.      (ante (x) (car x)))
  532.     (flet ((weaker-typed? (ante1 ante2)
  533.          (and (typed-var? ante1)
  534.           (typed-var? ante2)
  535.           (eq (typed-var-nm ante1) (typed-var-nm ante2))
  536.           (kb-subtypep (typed-var-type ante2)
  537.                    (typed-var-type ante1)))))
  538.       (if (null clauses)
  539.       (list clause)
  540.         (let ((ante1 (ante clause)))
  541.       ;; (format t "~%a1: ~S~%a2s: ~{~A~%~}" (ante clause) (mapcar #'ante clauses))
  542.       (if (member ante1 clauses :test #'equal :key #'ante)
  543.           ;; the antecedent is already in the clauses
  544.           ;; this indicate a many-to-one surface-to-abstract syntax
  545.           clauses
  546.         (let* ((clause2 (first clauses)) (ante2 (ante clause2)))
  547.           (if (conjunction? ante2)
  548.           (if (conjunction? ante1)
  549.               (if (subsetp ante1 ante2 :test #'weaker-typed?)
  550.               (cons clause2 (insert-clause clause (rest clauses)))
  551.             (cons clause clauses))
  552.             (if (typed-var? ante1)
  553.             (if (find-if #'(lambda (a) (weaker-typed? ante1 a))
  554.                      (conjuncts ante2))
  555.                 (cons clause2 (insert-clause clause (rest clauses)))
  556.               (cons clause clauses))
  557.               (cons clause2 (insert-clause clause (rest clauses)))))
  558.             (if (conjunction? ante1)
  559.             ;; ((and p q) ..) : p  --> ((and p q) p ..) 
  560.             (if (typed-var? ante2)
  561.             (if (find-if #'(lambda (a) (weaker-typed? a ante2))
  562.                      (conjuncts ante1))
  563.                 (cons clause clauses)
  564.               (cons clause2 (insert-clause clause (rest clauses))))
  565.               ;; ante2 is not typed, eg. (IDENTIFIERP %U)
  566.               (if (member ante2 (conjuncts ante1) :test #'equal)
  567.               (cons clause clauses)
  568.             (cons clause2 (insert-clause clause (rest clauses)))))
  569.           ;; both are simple
  570.           (if (weaker-typed? ante1 ante2)
  571.               (cons clause2 (insert-clause clause (rest clauses)))
  572.             (cons clause clauses)))))))))))
  573.  
  574. ;----------------------------------------------------------------------------;
  575. ; same-print-syntax
  576. ;------------------
  577. ; Given clauses rhs A and B
  578. ; where  <clause> = short-lambda-list syntax binding-list
  579. ; return true iff
  580. ; the syntax's constants are the same and its variables have the same bdg
  581. (defun same-print-syntax (a b)
  582.   (let ((a-syntax (clause-syntax a)) (b-syntax (clause-syntax b)))
  583.     (and (equal (length a-syntax) (length b-syntax))
  584.      (every #'(lambda (constituent1 constituent2)
  585.             (or (and (symbolp constituent1) (symbolp constituent2))
  586.             (and (stringp constituent1)
  587.                  (stringp constituent2)
  588.                  (string= constituent1 constituent2))))
  589.         a-syntax b-syntax)            
  590.      ;; syntax is the same
  591.      (let ((a-bdgs (clause-bl a)) (b-bdgs (clause-bl b)))
  592.        ;; do all variables of the lambda-list have the same path?
  593.        (every #'(lambda (u v)
  594.               (equal (cdr (assoc u a-bdgs))
  595.                  (cdr (assoc v b-bdgs))))
  596.           (clause-ll a)
  597.           (clause-ll b))))))
  598.  
  599. ;----------------------------------------------------------------------------;
  600. ; make-format-string-list
  601. ;------------------------
  602. ; This converts a rhs of a grammar rule (SYNTAX) to a format string. 
  603. ; It tries to infer when spaces should be inserted based on the
  604. ; parameter *identifier-continue-chars*
  605. ; As a "rule of style" if a token has a space to its left (right) it should
  606. ; also have one to its right (left), unless the token is the last in syntax.
  607. (defun make-format-string-list (syntax)
  608.   (let ((sep-sq (insert-seperator? syntax))
  609.     (a-tok "~a")
  610.     (s-tok "~s")
  611.     (blank " "))
  612.     ;; const1 const2 ... constn
  613.     ;; sep1   sep1   ... sep1
  614.     ;; enforce the rule of style that a grammar keyword has
  615.     ;; seperators on both sides if it has one on either
  616.     ;; this algorithm is too cuatious, since it does not hurt to
  617.     ;; introduce a seperator!
  618.     (do ((syn-tl syntax (cdr syn-tl))
  619.      (sep-tl sep-sq (cdr sep-tl))
  620.      Acc                ; accumulated result
  621.      )
  622.     ((null syn-tl) (nreverse Acc))
  623.       (let ((const (car syn-tl))
  624.         (sep?  (car sep-tl))
  625.         (preceding-blank? (and Acc
  626.                    (eql (first Acc) blank))))
  627.     (if (stringp const)
  628.         (progn
  629.           (when (and sep? (not preceding-blank?))
  630.         ;; when a seperator follows, then it must precede 
  631.         (push blank Acc))
  632.           (push (escape-tilde const) Acc)
  633.           (when (or sep?
  634.             ;; there is a preceding blank, and not at end
  635.             (and (cdr syn-tl) preceding-blank?))
  636.         (push blank Acc)))
  637.       (let ((firsts (first-terminal (constituent-name const))))
  638.         (if (and (null (rest firsts))
  639.              (string= "STRING" (first firsts)))
  640.         (push s-tok Acc)
  641.           (push a-tok Acc))
  642.         (when sep? (push blank Acc))))))))
  643.  
  644. (defun escape-tilde (string)
  645.   ;; precede each ~ by ~
  646.   (declare (string string))
  647.   (let* ((R "")
  648.      (tilde #\~)
  649.      (p0 0)
  650.      (p1 (position tilde string :test #'eql)))
  651.     (declare (fixnum p0 p1))
  652.     (if p1
  653.     (loop (setq R (concatenate
  654.                'string R (subseq string p0 p1) "~~"))
  655.           (setq p0 (1+ p1))
  656.           (unless (setq p1 (position tilde string
  657.                      :start p0 :test #'eql))
  658.         (return-from escape-tilde
  659.           (concatenate 'string R (subseq string p0)))))
  660.       string)))
  661.  
  662. (defun parse-id/number? (s &aux (n (length s)) state)
  663.   (declare (string s))
  664.   (or                    ; number
  665.    (dotimes (i n t)
  666.      (let ((c (schar s i)))
  667.        (if (null state)
  668.        (if (digit-char-p c)
  669.            nil
  670.          (if (eql c #\.)
  671.          (setq state t)
  672.            (return nil)))
  673.      (if (digit-char-p c)
  674.          nil
  675.        (return nil)))))
  676.                     ; id
  677.    (setq state nil)
  678.    (dotimes (i n t)
  679.      (let ((c (schar s i)))
  680.        (if (null state)
  681.        (if (find c *identifier-start-chars*)
  682.            (setq state t)
  683.          (return nil))
  684.      (if (find c *identifier-continue-chars*)
  685.          nil
  686.        (return nil)))))))
  687.  
  688. (defun insert-seperator? (s)
  689.   ;; -> seq of T/Nil depending on whether the element in s should
  690.   ;; be followed by a seperator
  691.   (declare (list s))
  692.   (flet ((continues-token? (e)
  693.        (declare (string e))
  694.        (or (zerop (length e))
  695.            (let ((c (schar e 0)))
  696.          (declare (character c))
  697.          (if (find c *identifier-continue-chars*)
  698.              t
  699.            (or (digit-char-p c)
  700.                (eql c #\.)))))))
  701.     (maplist #'(lambda (s-tl)
  702.          (let ((e1 (first s-tl)))
  703.            (if (null (rest s-tl))
  704.                ;; e1 is the last element
  705.                ;; by default no seperator after the last const
  706.                nil
  707.              ;; compare e1 to next element, e2
  708.              (let ((e2 (second s-tl)))
  709.                (if (symbolp e1)
  710.                (if (symbolp e2)
  711.                    t
  712.                  ;; the following string e2 could continue
  713.                  ;; the id e1
  714.                  (continues-token? (the string e2)))
  715.              (if (symbolp e2)
  716.                  ;; e1 is a string
  717.                  ;; if it could start an id or number, seperate
  718.                  (parse-id/number? e1)
  719.                ;; e2 is a string
  720.                ;; could it continue a number or an id
  721.                (continues-token? (the string e2))))))))
  722.          s)))
  723.  
  724. ;----------------------------------------------------------------------------;
  725. ; simplify-cond-clauses
  726. ;----------------------
  727. ;  ((and a1 b1) c1)
  728. ;  ((and a1 b2) c2 ..) ..
  729. ; (cond (a1 (cond (b1 c1) (b2 c2))) ..
  730.  
  731. (defun simplify-cond-clauses (clauses)
  732.   (flet ((conj1 (cl) (second cl))
  733.      (conj2 (cl) (third cl))
  734.      (and? (cl) (and (consp cl) (eq (car cl) 'AND))))
  735.     (let* ((cl1 (first clauses))
  736.        (ante1 (car cl1))
  737.        (rest1 (cdr cl1)))
  738.       (if (and (and? ante1) (rest clauses))
  739.       (let* ((cl2 (second clauses))
  740.          (ante2 (car cl2))
  741.          (rest2 (cdr cl2)))
  742.         (if (and (and? ante2) (equal (conj1 ante1) (conj1 ante2)))
  743.         `((,(conj1 ante1) (cond (,(conj2 ante1) .,rest1)
  744.                     (,(conj2 ante2) .,rest2)))
  745.           .,(cddr clauses))
  746.           clauses))
  747.     clauses))))
  748.  
  749. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  750. ;;                      Type Inference for Non-Terminals
  751. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  752.  
  753. (defun type->predicate (type)
  754.   (intern (concatenate 'string (symbol-name type) "-P")
  755.       (symbol-package type)))
  756.  
  757. (defun infer-type-predicate (var &aux (v (constituent-name var)))
  758.   (case v
  759.     (NUMBER     'numberp)
  760.     (IDENTIFIER 'identifierp)
  761.     (STRING     'stringp)
  762.     (t (let ((type (infer-type v)))
  763.      (if (eq type ':TOP)
  764.          (let ((domain-top (car (type-tree-node--subtypes
  765.                      *domain-type-hierarchy*))))
  766.            `(OR
  767.          ,(type-tree-node--label domain-top)
  768.          NUMBER SYMBOL STRING))
  769.        (if (consp type)
  770.            (if (null (rest type))
  771.            (type->predicate (first type))
  772.          (cons 'OR type))
  773.          (if (null type)
  774.          'T
  775.            (type->predicate type))))))))
  776.  
  777.  
  778. (defun infer-type (v)
  779.   (if (member v '(NUMBER IDENTIFIER STRING))
  780.       v
  781.     (let ((disj (infer-type-disj v)))
  782.       (if (null disj)
  783.       (warn "Could not infer type for ~S" v)
  784.     disj))))
  785.  
  786. ;----------------------------------------------------------------------------;
  787. ; is-subtype-of
  788. ;--------------
  789. ; 
  790. ; 
  791. (defun is-subtype-of (a b)
  792.   (or (eq a b)
  793.       (let ((type-nd (gethash a *domain-HT*)))
  794.     (when type-nd
  795.       (let ((sup (type-tree-node--supertype type-nd)))
  796.         (and sup
  797.          (is-subtype-of (type-tree-node--label sup) b)))))))
  798.  
  799. ;----------------------------------------------------------------------------;
  800. ; kb-subtypep
  801. ;------------
  802. ; disjunctive and conjunctive types are allowed
  803. ; 
  804. (defun kb-subtypep (a b)
  805.   (if (consp a)
  806.       (case (first a)
  807.     (OR (every #'(lambda (junct) (kb-subtypep junct b))
  808.            (rest a)))
  809.     (AND (some #'(lambda (junct) (kb-subtypep junct b))
  810.            (rest a)))
  811.     (T nil))
  812.       (if (consp b)
  813.       (case (first b)
  814.         (OR (some #'(lambda (junct) (kb-subtypep junct a))
  815.               (rest b)))
  816.         (AND (every #'(lambda (junct) (kb-subtypep junct a))
  817.             (rest b)))
  818.         (T nil))
  819.     (is-subtype-of a b))))
  820.  
  821. (defun check-domain-type (type node)
  822.   (unless type
  823.     (error "~S is not a defined domain type." node)))
  824.  
  825. (defun infer-type-disj (v &aux (nts (list v)))
  826.   ;; return a list of the possible types for a non-terminal V
  827.   (labels ((infer-type-aux (v disjuncts)
  828.          (if (or (member v '(NUMBER IDENTIFIER STRING))
  829.              (assoc v *lex-cats*))
  830.          (adjoin v disjuncts) 
  831.            (let ((zb-rule (assoc v *zb-rules*))
  832.              (types disjuncts))
  833.          (unless zb-rule
  834.            (error "No Rule/Non-terminal named ~s found" v))
  835.          (dolist (prod (zb-rule--productions (cdr zb-rule)) types)
  836.            (let ((s (production-rhs--semantics prod)))
  837.              (if s
  838.              (if (feat-term-p s)
  839.                  (setq types (adjoin-type-disj
  840.                       (feat-term--type s) types))
  841.                (dolist (type (infer-type s))
  842.                  (setq types (adjoin-type-disj type types))))
  843.                (let ((nt (find-if #'symbolp
  844.                       (production-rhs--syntax prod))))
  845.              (unless (or (null nt) (member nt nts))
  846.                (push nt nts)
  847.                (setq types
  848.                  (infer-type-aux nt types)))))))))))
  849.     (infer-type-aux v nil)))
  850.  
  851. (defun adjoin-type-disj (type disj)
  852.   (if (find type disj :test #'is-subtype-of)
  853.       disj
  854.     (cons type (delete-if #'(lambda (a) (is-subtype-of a type))
  855.               disj))))
  856.                        
  857.   
  858. (defun infer-type-disj-of-expr (x)
  859.   (typecase x
  860.     (number '(number))
  861.     (string '(string))
  862.     (symbol (infer-type-disj (constituent-name x)))))
  863.  
  864. ;----------------------------------------------------------------------------;
  865. ; find-path
  866. ;----------
  867. ; Given a typed feature-structure feat-term, and a variable V occuring
  868. ; somewhere as a value of a slot, return a path to it
  869. ; return: (1) if you are there ()
  870. ;         (2) if there is no path to v: :FAIL
  871. ;         (3) if there is some path: the first one found
  872.  
  873. (defun find-path (v feat-term)
  874.   (labels ((find-path-aux (avl)
  875.          (if (atom avl)
  876.          (if (feat-term-p avl)
  877.              (find-path-list (feat-term--slots avl)
  878.                      (feat-term--type avl))
  879.            (if (eq v avl)
  880.                t
  881.              :FAIL))
  882.            :FAIL))
  883.        (find-path-list (avl type)
  884.          (dolist (lv-pair avl)
  885.            (let ((p (find-path-aux (label-value-pair--value lv-pair))))
  886.          (unless (eq p :FAIL)
  887.            (return
  888.              (cons (intern
  889.                 (concatenate
  890.                  'string
  891.                  (symbol-name type) "-"
  892.                  (symbol-name (label-value-pair--label lv-pair)))
  893.                 (symbol-package type))
  894.                (if (eq p 't) nil p))))))))
  895.     (find-path-aux feat-term)))
  896.  
  897. ;----------------------------------------------------------------------------;
  898. ; partition-set
  899. ;--------------
  900. ; partition SET according to EQUIV-FN
  901. ; for equiv-fn holds (equiv-fn x y) = (equiv-fn y x)
  902.  
  903. (defun partition-set (equiv-fn set &aux alist)
  904.   (do ((x-set set (cdr x-set))) ((null x-set))
  905.     (let ((x (car x-set)))
  906.       (push (list x) alist)
  907.       (do ((y-set (cdr x-set) (cdr y-set))) ((null y-set))
  908.     (let ((y (car y-set)))
  909.       (if (funcall equiv-fn x y)
  910.           (let ((found-association (assoc x alist)))
  911.         (push y (cdr found-association))))))))
  912.   (labels ((partition-set-aux (alist)
  913.          (if (null alist)
  914.          '()
  915.            (let* ((pair1 (car alist))
  916.               (set1 (reduce #'union
  917.                     (mapcar
  918.                      #'(lambda (p)
  919.                      (let ((found (find-if
  920.                                #'(lambda (p1)
  921.                                (member p1 p))
  922.                                pair1)))
  923.                        (when found
  924.                          (setf alist (delete p alist))
  925.                          p)))
  926.                      (cdr alist)) 
  927.                     :initial-value pair1)))
  928.          (cons set1
  929.                (partition-set-aux (cdr alist)))))))
  930.     (partition-set-aux alist)))
  931.  
  932. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  933. ;;                                    tests
  934. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  935.  
  936. #||
  937.  
  938. (GEN-PRINTERS (find-grammar "ex1a"))
  939. (infer-type 'cl-user::ee)
  940. (infer-type 'cl-user::f)
  941. (infer-type 'cl-user::tt)
  942. (infer-type-predicate 'IDENTIFIER)
  943. (infer-type-predicate 'cl-user::ee)
  944.  
  945. (PARTITION-SET #'(lambda (x y)
  946.            (eql (schar (string x) 0)
  947.             (schar (string y) 0)))
  948.            '(a aa aaa b bbb bb c cccc))
  949.  
  950. (PARTITION-SET #'(lambda (x y)
  951.                 (eql (schar (string x) 0)
  952.                  (schar (string y) 0)))
  953.            '(a b c))
  954.  
  955. ;----------------------------------------------------------------------------;
  956. ; partition-set-by-selection-fn
  957. ;------------------------------
  958. ;;; partition set according to selection-fn
  959.  
  960. (defun partition-set-by-selection-fn (selection-fn set &aux alist)
  961.   (dolist (item set)
  962.     (let* ((key (funcall selection-fn item))
  963.        (found-association (assoc key alist :test #'eql)))
  964.       (if found-association 
  965.       (nconc (cdr found-association) (list item))
  966.     (push (cons key (list item)) alist))))
  967.   (dolist (pair alist)
  968.     (setf (car pair) (cadr pair)
  969.       (cdr pair) (cddr pair)))
  970.   alist)
  971.  
  972.  
  973. (partition-set-by-selection-fn #'evenp '(1 2 3 4 5 6 7 8))
  974.  
  975.  ==> ((2 4 6 8) (1 3 5 7))
  976. ||#
  977.  
  978. #||
  979. ;----------------------------------------------------------------------------;
  980. ; follow-terminal
  981. ;----------------
  982. ; given the name of a grammar-symbol, return the
  983. ; list of possibly following strings
  984. (defun follow-terminal (name)
  985.   (mapcar #'g-symbol-name
  986.       (oset-item-list (g-symbol-follow-set (g-symbol-intern name))))
  987.   )
  988. ||#
  989.  
  990. (defun first-terminal (name)
  991.   (mapcan #'(lambda (item)
  992.           (unless (eq item *empty-string-g-symbol*)
  993.         (list (g-symbol-name item))))
  994.       (oset-item-list (g-symbol-first-set (g-symbol-intern name)))))
  995.  
  996. #||
  997. (follow-terminal 'user::ARG)
  998. (first-terminal 'user::ARG*448)
  999. (follow-terminal 'user::ARG*)
  1000. (first-terminal 'user::Name)
  1001. (first-terminal 'Identifier)
  1002.  
  1003. (intersection (follow-terminal 'user::ARG) (first-terminal 'user::ARG*438))
  1004. (intersection (follow-terminal 'user::stmt) (first-terminal 'user::stmt+))
  1005.  
  1006. ||#
  1007. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1008. ;;                        End of zebu-generator.lisp
  1009. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1010.